perm filename UPDATE.IRC[IRC,LCS] blob
sn#513437 filedate 1980-05-30 generic text, type T, neo UTF8
MS.LCS[MUS,DOC] ************
---CODE 4 31/JAN/80
ADD 1000 MORE FOR THIN DOUBLE BAR. 2000,3000,4000 =RPTS.
REPT. BARS NUM OF | 0 | 0 | | | |
STAVES UP | | | | | |
+2000=DOTS TO RIGHT | | | | | |
+3000=DOTS RT & LFT | | | | | |
+4000=DOTS TO LEFT | | | | | |
MS *************
---MS.F4 15/JAN/80
CCC 24/1/80 590 IF(I2.NE.LDD)GO TO 600
590 IF(I1.EQ.LAA)JA=190
C 'AD'just stems to beams. 'A'=ADJUST LFT-RT POS. AFTER 'SET' COMMAND
1800 IF(REDIT.NE.55.)REDIT=0
C NEEDED FOR 'S'ET, THEN 'A'LIGNE ROUTINE
---------
1190 IF(R2.GT.1.OR.R3+R4.NE.0)GO TO 1195
R3=50.0
R4=50.0
C Z1 ONLY ADDS IN 50,50 SO WE CAN ZOOM UP AND DOWN AT ANY SIZE.
1195 IF(I2.GT.0)GO TO 1250
---------
DATA RZMSZ/1.0/,RZMX/50.0/,RZMY/50.0/
C DATA STATEMENT NEEDED TO GET CORRECT NUMS. FOR ZU,ZD, ETC. BEFORE Z1, ETC.
CZOO IF(R2.EQ.1)GO TO 1310
CZOO IF(R2.LT.1)GO TO 1300
JCEN=(R3*10-500)*RSZ
KCEN=(R4*10-480)*RSZ
C NEXT TO RECONSTITUTE SPACING SCALE.
1300 R2=(R4-100.)/100.
IF(K.GE.0)GO TO 610
C TYPE DP -1 FOR ALL INVISIBLE
DO 611 K=0,7
611 DP(K)=-1
GO TO 120
610 IF(K.EQ.8)K=0
C R = RIGHT MOVE, RI=RIT., RS=RESTART, READ=READ
660 IF(I2.GE.IBLA)GO TO 680
IF(I2.EQ.LEE)GO TO 200
C ABOVE FOR 'READ'(SAME AS 'FILE')
IF(X22.NE.0)GO TO 260
C GO BACK IF STILL IN EDIT MODE.
IF(I2.EQ.LSS)GO TO 10
C TYPE 'RS' TO RESTART.
CCCC IF(I2.EQ.LEE)GO TO 200
C ABOVE FOR 'READ'(SAME AS 'FILE') NEXT FOR RIT.=37
--------------
IF(R2.EQ.0)GO TO 1110
IF(R2.LT.1.0)GO TO 130
C CATCHES TYPOS. (I.E. DECI. NUMBER AFTER I)
GO TO 1110
750 IF(K)JA=55
--------------
IF(I2.EQ.LVV.OR.I2.EQ.LWW)CB=-1
IF(I3.EQ.LVV)CB=CB-10
C TYPE 'CB' FOR CENTER-BIG (BIG RANGE =6) ****** 'CV'=SET CURVE OF SLU
C CBV, CHV, CTV WILL SET CURVE AND DO CENTERING. CW CENTERS DASH BETWEEN WDS.
GO TO 1110
1770 IF(I2.EQ.IBLA)GO TO 1780
--------------
IF(I2.NE.LTT)GO TO 880
C JT=JUSTIFY TEXT (ONLY 1 STAFF AT A TIME)
1780 CALL MOVER
-------------- ************ SEE NEW ROUTINES DASHES, NEWMRK, MORMRK
IF(JA.NE.4)GO TO 2045
IF(CB.GE.0)GO TO 2050
CALL DASHES(ITEM,R2,R3,R4,R5,R6)
C SUBR. DASHES WILL CENTER DASH BETWEEN TO WORDS OR SYLLABLES. (TYPE 'CW')
GO TO 2060
2045 IF(JA.NE.5.OR.CB.GT.0)GO TO 2050
---CLEFS.F4
SUBR. MOVE
10 CALL VLINE(R2,R3,R4,R5)
R6=R5
R5=R4
R4=R3
CRR*** CHANGE R4,5,6 LATER *****10 CALL VLINE(R2,R4,R5,R6)
20 IF(IDEV.EQ.5)
1 CALL TYPSTR('TYPE NEW STAFF #, POS1, POS2, UP-DOWN # ')
READ(IDEV,F78F,END=100)R7,R8,R9,R11
IF(R7.LT.99)GO TO 21
R5=0
GO TO 10
21 IF(INP(1).NE.LCC)GO TO 1
IF(R2.GT.7.OR.R7.LE.7)GO TO 1
IF(R6.EQ.0)GO TO 20
C NOW WILL COPY ONE CODE NUM TO ALL OTHER ACTIVE STAVE.
CALL CPYALL
RETURN
1 IF(R2.LE.7.AND.R7.GT.7)GO TO 20
(EQUIV.)
2,(IR,R),(I2,INP(2))
110 IF(R4.EQ.0)R4=.001
IF(R5.EQ.0)R5=200
IF(I2.NE.'T')GO TO 115
IF(R2.GT.7.)RETURN
CALL JUSTXT(R2,R4,R5)
C 'JT' GO JUSTIFY TEXT. ONLY 1 STAFF AT A TIME
RETURN
115 NCNT=0
---SLRSCL.F4
SUBR. SETLET
30 MM=-1
K=JJ
300 LL=INP(K)
IF(LL.NE.' ')MM=0
IF(LL.EQ.KSLA)GO TO 301
IF(LL.NE.'?')GO TO 303
IF(INP(K+1).NE.?)GO TO 303
C NOW FOUND /??/ = DASH BETWEEN SYLLABLES
K=K+3
GO TO 300
303 IF(K.GE.72)GO TO 301
----------
JSET=ISET
22 IF(IFIX(RPOS(1,K)*100.).NE.IFIX(RPOS(1,K-1)*100.))GO TO 2
1301 NN=NN2
NN2=NN2+1
IF(NN.GT.1)GO TO 1267
READ(IDEV,F78F,END=167)V
IF(V(1).NE.99.)GO TO 2267
C READS 38 NUMS. 1ST TIME. NOW '99' = 1,2,3,...38 (VERT. PRESET)
X=0
DO 3267 LL=1,76,2
X=X+1.0
V(LL)=X
3267 V(LL+1)=RR4
5267 NN=76
GO TO 31
2267 IF(V(3).EQ.0)GO TO 267
C NOTE NUMS CAN BE ON 1 LINE IF THERE ARE >2. (VERT. POS. MUST BE PRESET)
NN=38
DO 4267 LL=76,1,-2
V(LL)=RR4
V(LL-1)=V(NN)
4267 NN=NN-1
GO TO 5267
1267 READ(IDEV,F78F,END=167)V(NN),V(NN2)
-----------
IF(RN(ISET+1).NE.16.)GO TO 6
C TRAP DASH AT FIRST OF LINE.
3 K=X
-----------
17 IF(RN(JSET+1).NE.4)GO TO 117
RN(JSET+3)=RN(ISET+3)+1.
C ASSUMES SOME CODE 16 CHAR. JUST BEFORE DASH.
CALL DASHES(IX,R2,RN(JSET+3),RN(JSET+4),RN(JSET+5),RN(JSET+6))
117 ISET=JSET
JSET=JSET+RN(JSET)+3
IF(JSET.LT.I)GO TO 17
END
---NOTBMS.F4
C clefs = 3xyz.0 z=0=treble, =1=bass, =2=alto, =3=tenor, neg.=invis.
C use TRE,BAS,ALT,TEN for clefs with no change to note levels.(4,5,6,7)
23 CLF=ABS(X)-3000.
IF(CLF.LT.4)GO TO 223
C NOW CLEFS THAT DON'T INFLUENCE NOTE LEVELS. (4,5,6,7)
CLF=CLF-4
GO TO 323
223 JCLF=CLF
IF(X.LT.0)GO TO 871
C IS THE CLEF INVISIBLE?
323 R5=CLF
---BEAMS.F4
C**** UPDN=2
B=B-100
IF(B.GT.100)B=100-B
C TYPE -NUM OR 200+NUM FOR DIP DOWN.
VX(JA)=B
UPDN=B
C***512 IF(B.LT.0)UPDN=1
512 RN(9+IS)=0
5061 MK=N
C*** 4/80 N=NN
C***CC N=IABS(NN)
N=IABS(NN)
201 IF(JSTEM.LE.IT)GO TO 577
C*** IF(UPDN.NE.0)GO TO 577
IF(UPDN.EQ.-1)GO TO 577
NN=-1
IF(UMAX+DMAX.LT.14)NN=-NN
C SETS AUTO. BEAMS' STEM DIRECTION.
IF(UPDN.NE.0)NN=UPDN
577 X=10
407 M=K+1
IF(R(1,M).NE.1)GO TO 603
IF(R(5,M).GE.10)GO TO 603
C FINDS DBL+ STP ON LAST OF BEAM
IF(R(6,M))GO TO 603
C JUMP OUT IF A WHITE NOTE
K=M
GO TO 407
603 DO 3 M=KN,K
677 IF(JSTEM.LE.KN)GO TO 55
C IGNORE STEM DIR. IF ALREADY SPECIFIED WITHIN THIS GROUP
AA=R(5,M)
CXX IF(AA.LT.10.)GO TO 3
CXX STMDR=AA
IF(AA.GE.10.)STMDR=AA
143 JA=KN+1
IF(R(1,JA).NE.1.OR.R(5,JA).GE.10)GO TO 144
M=K+1
IF(R(1,M).NE.1.OR.R(5,M).GE.10)GO TO 144
IF(R(4,JA).EQ.R(4,M).AND.R(4,KN).EQ.R(4,K))B=A
C MAKE BEAM LEVEL IF SAME DYAD AT START AND END.
144 IF(X.GE.20)GO TO 530
---HOMX.F4 3/80
CXX **** FIX AT IRCAM 1/80 ***** IF(I(1).NE.LCC.AND.I(2).NE.LOH)GO TO 30
IF(I(1).NE.LCC.OR.I(2).NE.LOH)GO TO 30
****** SEE ENTIRE 'RREAD' AND 'NUMZ' ROUTINES ***** (IN HOMX.F4)
---SCMSS.F4
912 CALL TYPSTR(' SPACING STAFF=')
CALL TYPFLT(SET4)
911 CALL TYPCRL
11 RB=0
IF(MODE.LE.2)GO TO 111
IF(IDEV.EQ.1)GO TO 111
C SKIP IF READING AN EDIT FILE
444 SET4=RA
GO TO 912
REREAD 2114,INP
C IF(IDEV.NE.5)GO TO 5333
C WRITE(21,2114)INP
IF(IDEV.EQ.5)WRITE(21,2114)INP
C WRITE OUT SPACING INFO
IF(INP1.GT.0)GO TO 4334
CCC NOW FOUND LETTER WHERE WE WANT NUMB.
IF(IDEV.EQ.5)GO TO 4333
CALL TYPSTR(' POS1, POS2 MISSING')
CALL TYPCRL
GO TO 999
4334 STUP=STUP-PSFB
----------------
JBKUP=0
C JBKUP IS TO TRAP MORE THAN ONE BACKUP IN A ROW.
1177 RB=0
----------------
IF(MODE.GE.4)GO TO 1999
IF(JBKUP.LT.0)GO TO 199
JBKUP=-1
MODE=MODE-1
IF(MODE.EQ.0)GO TO 999
IS=ISV(MODE)
GO TO 11
C INSERT BACKUP ROUTINE
999 REND=99
GO TO 2111
C FIX BACKUPS********
199 CALL TYPSTR('ONLY 1 BACKUP AT A TIME. ')
299 CALL TYPSTR('CONTINUE, THEN EDIT .DAT FILE LATER, OR TYPE 999.')
CALL TYPCRL
GO TO 367
1999 CALL TYPSTR('CANNOT BACKUP AFTER MARKS INPUT.')
CALL TYPCRL
GO TO 299
----------------
766 GO TO(1,2,3,4,5)MODE
767 IF(INP1.NE.IBLA)GO TO 5177
6177 CALL LNEND
IF(INP1.EQ.ISEMI)GO TO 7774
C INP1=; MEANS UNTERMINATED LINE WAS TYPED. GO TRY AGAIN.
----------------
2999 CONTINUE
7774 CALL TYPSTR('****** TRY AGAIN ***** ')
CALL TYPCRL
GO TO 766
CC GO TO 1
---RHYTH.F4 29/JAN/80
70 KZ=ITEM-1
IF(IDEV.NE.1)KZ=KZ-IZ
C WHEN READING FILE, NOTES ARE NOT DISPLAYED, HENCE ITEM COUNT
C HAS NOT INCREASED BY VALUE OF IZ.
DO 370 K=1,KZ
----------------
POS=R(3,K-1)+4
C DON'T BACK OUT OF ARRAY
IF(K.EQ.1)POS=POS1
GO TO 76
75 POS=RPOS(1,J)
KZ=J+1
C FOUND SAME TYPE OF ITEM.
IF(K.EQ.1)GO TO 76
RA=R(3,K-1)
C GET POSITION OF PREVIOUS ITEM
IF(POS.LT.RA)POS=RA+3
C ARBITRARY POSITION FOR CLEF IF IT TRIES TO MATCH ONE SOMEWHERE ELSE.
76 R(3,K)=POS
---MARKZ.F4
25 CALL XREAD
IF(VX(1).EQ.0)CALL NEWMRK(INP,VX)
C ABOVE FOR NEW MARKS INPUT FORMAT.
----------------
305 CALL RNX(A,B,STAFF,C,BB,RC,0,X,0)
C RNX FILLS PARAMS 0→8
IS=IS+NN
IF(B.EQ.3.OR.B.EQ.6)GO TO 230
C B=6=TREM. NN=6=WORDS OR LTRS. UNDER STAFF.
1 J=J+1
IF(VX(J).EQ.0)GO TO 1
C ABOVE FOR NEW MARKS FORMAT. (I HOPE IT'S COMPATIBLE WITH OLD!)
----------------
552 IF(MX.EQ.0)GO TO 553
C GO GET REST OF LINE THAT WAS TOO LONG FOR NEW FORMAT
CALL MORMRK(MX,MZ,71,VX)
J=1
GO TO 505
553 CALL BMREAD
---SUBROUTINE XREAD---
CXCX 500 REREAD F78F,VX
500 CALL RREAD(INP,VX)
---SUBR. MARKS ----
80 IF(ML.EQ.MINUS)GO TO 86
IF(ML.NE.MR)GO TO 85
CRR***CX IF(ML.NE.MR)GO TO 85
CRR*** IF(VX(J+2).NE.0)GO TO 85
---SLURZ.F4 23/JAN/80
C=RN(6+IS)-RN(3+IS)-C*RSTJ2
CATCHES VERY SHORT SLURS - OR 1ST NOTE HAS 2 OR MORE TAILS (PUTS SLUR ABOVE)
IF(AMOD(R(7,M),10.0).GE.2.)C=-1
---CODE4.FAI 30/JAN/80
IDIVI 02,1750
SKIPN .COMM.+=26 ;IF(J5.NE.0)GO TO RPTBAR
CAIG 2,1 ;IF(DBR.LT.2)GO TO RPTBAR
JRST RPTBAR
AOS .COMM.+=26 ;J5=1
CAIN 2,4 ;IF(DBR.EQ.4)DBR=1
MOVEI 2,1
MOVEM 2,DBR ;FOR REPEAT DBL.BAR WITH P5=0
RPTBAR: MOVEM 02,DBR ;P4=2000=DOTS ON RIGHT, =3000=BOTH SIDES
;=4000=DOTS ON LEFT
---WORDS.F4
C******** DASH
368 IF(INP(L).NE.'?')GO TO 117
C /??/ = PUT IN DASH TO DIVIDE SYLLABLES. BUT MUST BE EDITED LATER!!!!!
IF(INP(L+1).NE.'?')GO TO 117
L=L+2
217 IF(INP(L).EQ.'/')GO TO 317
L=L+1
IF(L.LT.KN)GO TO 217
317 L=L+1
RN(IS)=8.
RN(IS+1)=4.
RN(IS+2)=R2
RN(IS+3)=RA-4.
RN(IS+4)=R4
RN(IS+5)=R4
RN(IS+6)=RA
RN(IS+7)=0
RN(IS+8)=0
RN(IS+9)=0
RN(IS+10)=1.
IS=IS+11
RZ=0
GO TO 1370
C******** DASH
117 RN(IS+1)=16
RN(IS+3)=RA
C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
--------------
391 IF(N.LT.64.OR.N.GT.68)CALL SPACER(K,IFNT,RX,3.32)
CC 63=SLASH 391 IF(N.LT.63.OR.N.GT.68)CALL SPACER(K,IFNT,RX,3.32)
--------------
C*** IF(RZ.NE.0)GO TO 370
C SKIP IF P10=1, REQUIRED FOR CONTINUATION OF TEXT.
C*** IF(IBLANK(IS,7))RZ=-2
C IF LAST CHAR IN P7 IS BLANK RESET WDCNT, GET RID OF P8 AND P9
C*** IF(IBLANK(IS,6))RZ=-3
C ↑↑↑↑ LAST CHAR IN P6=BLNK ZAPS P7 IF NOT NEEDED. RZ=- CHANGES WORDCNT
C***370 RN(IS)=7+RZ
C NOW WILL PUT SIZE INTO P9 ALWAYS. (FOR CODE 4 DASH CENTERING FEATURE.)
370 IF(RZ.LT.0)RZ=0
C***370 RN(IS)=7+RZ
RN(IS)=7+RZ
IS=IS+10+RZ
RZ=1.
IF(IA.EQ.KSLA)RZ=0
1370 LL=LL+1
IX=ITEM+LL-1
C IX IS FOR DASHES
IF(KNT.GT.0)CALL SETLET
JUSTFY ****************** 1/FEB/80
C ADD A LITTLE SPACE IN FRONT OF DBL BAR.
IF(KX.GT.1)GO TO 229
IF(RL.LT.3)GO TO 25
C JUMP IF THIN DBL BAR. OLD DBL BAR HAS 1 IN P5.
CCC IF(KX.EQ.1.OR.KX.EQ.3)RD=RD+RD
229 IF(KX.NE.2)RD=RD+RD
C 2=DOTS TO RT. 1 OR 4=DOTS TO LFT. 3=DOTS ON BOTH SIDES.
C REPT BAR WITH DOTS TO LEFT. ADD SPACE IN FRONT OF IT.
RB=-RB/RBX
IF(KX.EQ.4)KX=0
129 IF(KX.GE.2)RB=RBZ*RB
-----------
4 IF(RA.NE.2)GO TO 33
C NEXT FOR DOTTED RESTS - IN P6
IF(RL.LT.6.)GO TO 44
IF(RN(L+8).LT.0)GO TO 250
C P8=-1 MEANS WHOLE MEASURE REST (NEVER DOT, P6 CAN HAVE NUMB.)
44 IF(RL.GE.4)RB=RN(L+6)*1.5
----------- FOR CLEFS 5/80
IF(JX.EQ.0)GO TO 17
IF(RN(JIR).EQ.4.)GO TO 17
C JUMP IF THIS IS FIRST ITEM OR PREVIOUS ITEM WAS BAR LINE
C RC = NEEDED SPACE FROM PREVIOUS ITEM (SETUP AT 17)
IF(R(1,K+1)-R(1,K).LT.RC)GO TO 17
C JUMP IF NOT REALLY ENOUGH SPACE FOR CLEF
JIR=L+3
RD=RN(JIR)-R(1,K-1)
C RD=SPACE FROM PREV. ITEM TO CLEF
IF(RD.GE.RC)GO TO 17
C ALREADY ENOUGH SPACE TO LEFT OF CLEF
RC=RN(JIR)+RC-RD
C NOW NOT ENOUGH TO LEFT BUT PLENTY TO RIGHT - SO MOVE CLEF TO RIGHT
RN(JIR)=RC
R(1,K)=RC
C RESET POSITION LOCATIONS
RB=0
GO TO 17
29 IF(RA.NE.4)GO TO 26
GREDX.F4 *******************
SUBR. GRED
POS=0
C ABOVE FOR NEW RREAD IN MS.
7 CALL VLINE(R2,Z,POS,RX)
---NTS.FAI
N1253: MOVEM 12,ALF+=60 ; ABOVE IS NEW NOTES ROUTINE
MOVEI 0,1
MOVEM TRI# ;FOR TRIPLE-THICK X NOTES, HARMONICS.
MOVE .COMM.+4 ; ***** THEY ARE DOUBLE-THICK NOW. 4/80 ***
--------------
;;; SKIPL TRI ;IF(TRI.LT.0)ALL DONE ****THIS AT NRDR:+c.9*******
SKIPLE TRI ;IF(TRI.LT.0)ALL DONE DIAMOND AND X NOTES 2 THICKNESSES NOW.
---LINES.FAI
;; SO WE CAN ZOOM UP,DOWN,LEFT,RIGHT AND ANY SIZE MOVE T,[=0.8571]
;; CAML T,SIZ
;; JRST L6
SUB M,SIZ+1 ; M=M-JCEN
SUB N,SIZ+2 ; N=N-KCEN
L6: MOVEM M,EX#
---SLOOP.FAI 3/1/80
C10: MOVEI V,3 ;L=3
MOVEM V,L
MOVE KK,.COMM.+=27 ;10 DO 3 K=J6,J7,KQ
---LOOP.FAI JAN/80
CAML [5.0] ;FOR ONLY SINGLE CODE # ON ALL LINES. CAMGE [5.0]
JRST E144 ; " ARE WE IN BOUNDS?
JUMPE 5,.+3 ; IF 0, ANY CODE NUM. WILL DO
CAME 5,XRN(1) ; IS IT THE RIGHT CODE NUM?
JRST E144 ; WRONG CODE NUM.
CAMG 4,[7.0] ; STAFF NUM .GT. 7?
CAMN 4,XRN+1(1) ; OR IS IT SPECIFICALLY THE RIGHT STAFF NUM?
JRST E344
---SCAN.FAI
MOVE 02,[3001.0] ;BASS CLEF=3001
SCLEF: MOVE N,INP(ML) ;N=INP(ML+1) GET 3RD CHAR.
CAMN N,LBL ;IF(N.EQ.' '.OR.N.EQ.'/'.OR.N.EQ.';')GO TO SCLF
JRST SCLF ;IF 3RD CHAR IS SIGNIFICANT THEN SPECIAL CLEF
CAME N,LSL ; 4,5,6,7 = 0,1,2,3 BUT NO INFLUENCE ON NOTE LEVEL
CAMN N,ISEMI
JRST SCLF
FADR 2,[4.0]
AOS ML ;ML=ML+1
LNEND: 0 ;SEE FORTR. TEXT IN WORDS.F4
SETZ 4, ;IF BAD INPUT PUT ISEMI INTO ALF(4) [INP1] AT END
---ALPHA.FAI 15/JAN/80
BLANK: 0.70 ;NEW SIZE FOR BLANKS 1/80 (OLD SIZE WAS 1.0)
SPACER: 0 ;CALL SPACERR(J5,IFNT,RB,R)
MOVE @(16) ; J5 FOR NOW
CAILE =47
JRST SP10
CAIG =9
JRST SP117
CAIGE =36
JRST SP10
SP117: MOVSI 3,201400 ;[1.0] AC3 IS RSX
;************************ NEW BLANK SIZE *******************
CAIN =47 ;IS IT A BLANK?
MOVE 3,BLANK ;IT IS! NEW SIZE=.70, OLD SIZE=1.0 CHANGE IN DDT IF NEEDED.
PAGE **************
---PAGE.F4 18/JAN/80
COMMON /PX/KPN(400) /Q/Q(3500) /KBAR/KBAR(1027) /IRST/IRST
IF(R.NE.16)GO TO 113
IF(RN(J+5).LT.100)GO TO 577
GO TO 1113
113 IF(R.NE.10)GO TO 577
C SKIPS PAGE NUMS. (I.E. P7 > 2)
IF(RN(J+6).LT.100)GO TO 577
C SAVE NUMBER IF SIZE FACTOR(R6) IS +100 (JUST LIKE CODE 16, P5)
RN(J+4)=RNMHT
RN(J+6)=RNMSZ
C THE ABOVE SET HEIGHT AND SIZE OF REHEARSAL NUMS.
1113 RN(J+2)=0
-------- NEW STUFF FOR GETTING WORDS OFF ALL FILES
1 /JWDS/JWDS(300),RRN(3000)
DATA FIB/.7/,RSPC/25./,PGNUM/1.6/,RNMHT/16.0/,RNMSZ/1.0/
-----------
NCNT=10000
IFOUND=0
TYPE 1000
------------
IFOUND=-1
C FLAG TO SAVE RN AND KWDS ARRAYS
CZ IF(NXX.GT.1)NXX=-NXX
C THIS TAKEN OUT 3/7/80 BECAUSE DIDN'T FIND WORDS IN LOWER FILES.
------------
IF(IFOUND.GE.0)GO TO 877
IFOUND=-IFOUND
JTEM=ITEM+1
DO 1877 K=1,JTEM
1877 JWDS(K)=KWDS(K)
DO 2877 K=1,KWDS(JTEM)
2877 RRN(K)=RN(K)
C NOW DATA FOR THIS INST. IS SAVED.
----------------
CZ IF(NXX.GT.0)GO TO 877
C NEXT FOR PARTS ONLY. TO SKIP A FILE (OR MORE)
CZ NAME=NAME-2*(NXX+1)
CZ NXX=1
------------
C**** IF(LK.EQ.1)GO TO 2112
IF(LK.EQ.1)GO TO 2113
CX DO 3112 K=1,LK
CX3112 Q(K)=SAVES(K)
CALL RLOOP(Q,SAVES,LK)
C PUTS SAVED THINGS INTO Q ARRAY AND POINTER ARRAY (KPN)
CX DO 4112 K=2,LLL
CX4112 KPN(K)=KSAVE(K)
CALL RLOOP(KPN,KSAVE,LLL)
KPN(1)=1
2113 IF(IPG.EQ.0)GO TO 2112
IF(IFOUND.EQ.0)GO TO 2112
IFOUND=0
DO 183 K=1,JTEM
183 KWDS(K)=JWDS(K)
DO 283 K=1,KWDS(JTEM)
283 RN(K)=RRN(K)
ITEM=JTEM-1
C NOW GOT BACK DATA FOR SINGLE INST.
C THIS SECTION COLLECTS ALL ITEMS TO USED LATER(NOT EVERYTHING IF 'PARTS')
2112 DO 6 K=1,ITEM
---WRTPAG.F4
1 /RSIG/RSIG(0/7)
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
----------
SIG=-CLEF
100 CALL FILEIN
---------
34 IF(R.NE.17)GO TO 37
SIG=Q(JK+5)
IF(ABS(SIG).GE.100.)SIG=99
IF(IPG.LT.0)RSIG(LL)=SIG
---------
IF(SIG.NE.99)R3=10
KK=JK
435 LL=KPN(KKK)
---PGSUB.F4 (FILEIN) 18/JAN/80
JP=JJ2+KPX
IF(JP.LE.400)GO TO 1211
TYPE 3211,JP
STOP
3211 FORMAT(' ARRAY OVERLOAD. KPN=',I3,'/400')
4211 FORMAT(' ARRAY OVERLOAD. Q=',I4,'/3500')
1211 JP=KQ+JPQ
IF(JP.LE.3500)GO TO 2211
TYPE 4211,JP
STOP
2211 IF(KPX.EQ.1)GO TO 140
----------
3011 IF(CLEF.NE.99)CALL STAFF(3.,3.,1.5,0,CLEF,0,0,0,0,0,0,0)
IF(SIG.EQ.99.OR.Q(2).EQ.17.)GO TO 3211
C ***** SKIP IF NO KEY SIG. OR KEY SIG. ALREADY APPEARS ON THIS LINE.
----------
520 KQ=Q(KPN(KPX)+1)
IF(KQ.NE.18.AND.KQ.NE.44.AND.KQ.NE.3.AND.KQ.NE.17)GO TO 120
----------------
311 OLD=Q(KPN(KPX-1)+3)
B=0
JJ=JJ2+KPX-2
CC*******3/27/80 CHANGED TO -2 JJ=JJ2+KPX-1
---PTMOVE.F4 14/JAN/80
1 /IPG/IPG,JPG,BRACK(8),RSTNUM(8),RPSZ(8)
----------------
CALL JUSTFY(JPG-1,R,IR,KR,NP,RN,RPSZ,-1.0,R4,R5,R6,R8,R9)
C RPSZ HAS ADJUSTED SIZE FACTOR FOR EACH STAFF.
CCC CALL JUSTFY(JPG-1,R,IR,KR,NP,RN,RSTFAC,-1.0,R4,R5,R6,R8,R9)
---TRNSP.F4 (SUBROUTINE CUES) 4/FEB/80
RNN=RN(N+4)
IF(RNN.LT.100)RN(N+4)=RNN+100.
C MAKE ALL NOTES INTO MINIS AND PUT ON STAFF 0
44 RN(N+2)=0
IF(R.NE.3)GO TO 55
C IS IT A CODE 3? CHANGE NON-CLEFS TO CODE 33.
IF(RN(N+5).LT.6)GO TO 66
C JUMP FOR REAL CLEF
RN(N+1)=33
GO TO 55
66 RN(N+4)=100
C ALWAYS MINI-CLEF IN CUES.
55 IF(R.GT.2)GO TO 5
JJ=N+11-R*2.0
RN(JJ)=RN(JJ)/2.
C JJ=9 OR 7. CUT RHYTH VALS OF CUES 1/2 - SO THEY WILL OCCUPY LESS SPACE.
---FNDTRN.F4
20 FORMAT(' TYPE NUM OF QTRS
1 NEEDED FOR TURN, NUM OF PAGES, LNS PER PG., 1ST PG. NUM.'/)
MP ************
---MPRNT.F4 15/JAN/80
X=X*2.54
CALL TYPFLT(X)
CALL TYPSTR(' CM. ')
---PLOT3.FAI 14/FEB/80 (SEE PLOT4.FAI FOR VARIAN OUTPUT.****)
JRST PL1
MOVE 4,@(16) ;IF(X2.EQ.X1.AND.Y2.EQ.Y1)RETURN
MOVE 5,@1(16) ;AVOID DUPLICATE COORDS.
CAMN 4,X1
CAME 5,Y1
JRST DIFRNT
SKIPL @2(16) ;SKIP IF -3 IN PEN CODE
JRA 16,3(16) ;RETURN
DIFRNT: MOVEM 4,X1
MOVEM 5,Y1 ;SAVE X AND Y FOR NEXT TIME
AOS 7,LX ;L=L+1
EXTERNAL EXTOUT,FINEXT,EXIT,PUTEXT,OUTF,TTOP,DL
;; COMMON /DL/RSIZ,SAVER,NAME,EXT
MOVE 4,DL ;MOVEI 4,=127 ;N(1)=127
FMPR 4,[1000.0] ;SAVE SIZE FACTOR*1000 IN FIRST WORD.
KIFIX 4,4 ;WILL BE USED BY SEGMENT SYSTEM.
MOVEM 4,N
MOVE 4,[ASCIZ/" "/] ;IF(JJ.EQ.' ')JJ='PLT'
BIGGET.FAI *********
EXTOUT: MOVEI 0,@0(16)
EXTIN: MOVEI 0,@0(16)
XM.FAI******** AND OTHERS
READ1: IN DSK, ;READ FIRST BUFFER
SKIPA
HALT ;ERROR
HRR C,IBUF+1
MOVN E,1(C) ;LOOK FOR SIZE FACTOR. IF FOUND SKIP THIS BUFFER.
CAIGE E,177 ;FIRST WD HAS SIZE * 1000, NOT WDCNT
MOVNI E,177
JRST PLOTX ;IF(E.LT.-177)E=-177
OUTER: IN DSK,
PLOT: HRR C,IBUF+1
MOVN E,1(C) ;FIX FOR NO WDCNT
PLOTX: MOVSI E,(E)